perm filename ARMY.SAI[CMS,LCS] blob sn#109260 filedate 1974-07-03 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	
C00004 00003	
C00009 00004	SUBR COMND
C00013 ENDMK
C⊗;

BEGIN "ARMY"
	REQUIRE "GEOMES.HDR[GEM,HE]" SOURCE_FILE;
	DEFINE α="COMMENT";
	DEFINE π="3.1415927";
	DEFINE SUBR="SIMPLE PROCEDURE";
	DEFINE ISUBR="SIMPLE INTEGER PROCEDURE";
	DEFINE THRU="STEP 1 UNTIL";
	DEFINE ⊂="BEGIN";
	DEFINE ⊃="END";

	EXTERNAL SIMPLE REAL PROCEDURE ACOS(REAL W);

	INTEGER FRATE,CHR,GRAV,TAKE,IP,X,Y,Z;
	REAL NR,NT;STRING STR;

SUBR INIT;	α INITIALIZATION;
BEGIN "INIT"
	MKUNIV;GEODPY;
	X ← 0;Y ← 3;Z ← 6;
	IP ← 0;TAKE ← 1;
	FRATE ← 20;
	OUTSTR("   FRATE =");STR ← INCHWL;
	IF LENGTH(STR)≠0 THEN FRATE ← INTSCAN(STR,CHR);
	NT ← 1.0/FRATE;NR ← NT*π;GRAV ← 32*NT;
END "INIT";


SIMPLE REAL PROCEDURE ANGL(INTEGER B1,A1,B2,A2);
BEGIN "ANGL"
	REAL ANG;
	B1 ← A1+LOCOR(B1);
	B2 ← A2+LOCOR(B2);
	ANG ← ACOS(IX(B1)*IX(B2)+IX(B1+1)*
	IX(B2+1)+IX(B1+2)*IX(B2+2));
	RETURN(ANG);
END "ANGL";

ISUBR BUMP(INTEGER B1,B2,AX1,AX2;REAL MINA,MAXA,SP);
BEGIN "BUMP"
	INTEGER STP;
	REAL ANG;
	IF B1<0 THEN B1 ← -B1;
	ANG ← SP+ANGL(B1,AX1,B2,AX2);
	IF ANG<MINA∨ANG>MAXA THEN STP ← -1
	ELSE STP ← 0;
	RETURN(STP);
END "BUMP";

ISUBR BEND(INTEGER BAC,BD1,BD2,AR1,AR2,AR3;REAL MN,MX,SP);
BEGIN "BEND"
	INTEGER PAST;
	REAL RO,RX,RY,RZ;
	SP ← NR*SP;RO ← SP;
	IF BAC=2 THEN SP ← -SP;
	IF BUMP(BD1,BD2,AR2,AR3,MN,MX,SP) THEN BEGIN
	  PAST ← -1;
	  IF BAC THEN BEGIN
	    IF BAC>0 THEN RETURN(PAST);
	    RO ← -RO;
	    END;
	  END
	ELSE PAST ← 0;
	RX ← RY ← RZ ← 0;
	CASE AR1 OF ⊂ [0] RX ← RO;[3] RY ← RO;[6] RZ ← RO ⊃;
	ROTATE(BD1,RX,RY,RZ);
	RETURN(PAST);
END "BEND";

SUBR PLOP;
BEGIN "PLOP"
	IF TAKE>0 THEN ⊂ IF TAKE>1 THEN SHOW2(0,1)
		       ELSE GEODPY;RETURN;⊃;
	IF TAKE<-1 THEN SHOW2(0,1) ELSE GEODPY;
	IP ← IP+1;
	OUTSTR(" FRAME "&CVS(IP));PLOTO("FRM."&CVS(IP));
END "PLOP";
SUBR COMND;
BEGIN "COMND"
	INTEGER GIRL,GIR2,YES,NO,TWO,LC;
	REAL DG4,DG5,DG7,DG11,FAST,SLOW,FASTER,TS;

SUBR GAPO;
BEGIN "GAPO"
	TRANSL(GIRL,0,0,TS);PLOP;
END "GAPO";

 SUBR NOD(INTEGER B1,UPDOW;REFERENCE REAL SP);
 BEGIN "NOD"
	INTEGER A1,A2,A3,HD;
	REAL MN,MA;
	HD ← CCW(CCW(CCW(CCW(B1))));
	IF UPDOW THEN ⊂ A1 ← X;A2 ← Z;A3 ← Y;
	  MN ← DG7;MA ← DG11;⊃
	ELSE ⊂ A1 ← Y;A2 ← X;A3 ← Z;MN ← DG4;MA ← DG5;⊃;
	IF BEND(YES,-HD,B1,A1,A2,A3,MN,MA,SP) THEN SP ← -SP;
 END "NOD";

ISUBR SALUTE(INTEGER B1;REAL SP);
BEGIN "SALUTE"
	INTEGER I,RS,RA,T1;
	REAL MI,MX,MB;
	RS ← B1;
	FOR I←1 THRU 18 DO RS ← CCW(RS);
	RA ← CCW(RS);
	MB ← π/1.7;MX ← π/2;I ← 3;SP ← -SP;
	MI ← 0;
	I ← I+BEND(TWO,-RA,RS,X,Y,Y,MI,MB,SP);
	I ← I+BEND(TWO,-RS,B1,Z,Y,Y,MI,MX,SP);
	I ← I+BEND(TWO,-RS,B1,X,Z,Z,MI,MX,SP);
	RETURN(I);
END "SALUTE";

SUBR SCENE;
BEGIN "SCENE"
	INTEGER IT,I2;
	REAL SP1,SP2;
	SP1 ← SP2 ← FASTER;
	FOR IT←1 THRU 10 DO
	⊂ NOD(GIRL,YES,SLOW);
	  NOD(GIR2,NO,FAST);GAPO;⊃;
WHILE TRUE DO
	⊂ IT ← SALUTE(GIRL,SP1);
	  IF IT=0 THEN ⊂ IF SP1<0 THEN RETURN;SP1 ← -SP1;⊃;
	  I2 ← SALUTE(GIR2,SP2);
	  IF I2=0 THEN ⊂ IF SP2<0 THEN RETURN;SP2 ← -SP2;⊃;
	  IF IT+I2 THEN GAPO;⊃;
END "SCENE";

	GIRL←INB3D("LYN[CMS,LCS]");
	GIR2←INB3D("LYN[CMS,LCS]");
	GEODPY;

	NO ← 0;YES ← -1;FAST ← .8;SLOW ← .5;
	FASTER ← .8;TS ← NT/3;TWO ← 2;
	DG4 ← π/4;DG5 ← DG4*3;
	DG7 ← π/2.5;DG11 ← π/1.8;

WHILE TRUE DO
 BEGIN
	LC ← INCHRW;
	IF LC="P" THEN ⊂ TAKE ← -2;PLOP;⊃;
	IF LC="S" THEN SCENE;
	IF LC="G" THEN GEOMED;
 END;
END "COMND";



        α MAIN EXECUTION;
	OUTSTR(12&12&12&12&12);
	INIT;
	COMND;

END "ARMY";